perm filename CB.F4[DRW,LCS]4 blob
sn#423419 filedate 1978-11-17 generic text, type T, neo UTF8
SUBROUTINE CMBN
COMMON /RC/MCLEF(400),IST(4000)
COMMON /FL/NX,N,L,M,NM,J,NT
DIMENSION IP(10),NMS(10),NF(2500),JP(10),NMX(10)
EQUIVALENCE (IP,IST(3001)),(NMS,IST(3020)),(NF,IST(201))
1,(JP,IST(1500)),(NMX,IST(1510))
C ***** ****** **** ****** ↑ 20 FOR OVERRUN IN IP(11) AT 119
C USE FILE NAMES CLFX, DRAW1 AND DRAW2. 400 WD LIMIT PER FILE.
IF(N.EQ.'S')GO TO 103
102 TYPE 1
1 FORMAT(' TYPE OUTPUT FILE NAME ',$)
10 FORMAT(A5)
DO 122 K=1,10
IP(K)=0
122 NMS(K)=' '
ACCEPT 10,NM
IF(NM.NE.' ')GO TO 40
NM=LASTNM
TYPE 107,LASTNM
40 LASTNM=NM
IF(LOOKF(NM).EQ.0)GO TO 100
IF(N.NE.'C')GO TO 103
C FOR ADDING TO COMBINED FILE.
TYPE 101,NM
ACCEPT 10,NX
IF(NX.EQ.'N')GO TO 102
100 IF(N.EQ.'C')GO TO 104
TYPE 52
GO TO 102
104 L=0
NX=1
I=0
30 L=L+1
TYPE 41
41 FORMAT(' TYPE FILE NAME ',$)
ACCEPT 10,NW
IF(NW.EQ.' ')GO TO 8
IF(LOOKF(NW))GO TO 51
TYPE 52
GO TO 30
52 FORMAT(' FILE NOT FOUND'/)
51 I=I+1
IP(L)=NX
NMS(I)=NW
CALL RDSAV(JP,NMX,K,NW,MCLEF(NX),-2)
NX=NX+K
IF(L.LT.10)GO TO 30
101 FORMAT(' WRITE OVER ',A5,'.DMD? Y OR N? ',$)
8 NX=NX-1
14 CALL RDSAV(IP,NMS,NX,NM,MCLEF,0)
L=NX
RETURN
1103 TYPE 1104,ID
1104 FORMAT(' FILE FULL -- SAVED AS ',A5)
L=1
NM=ID
NX=MCLEF(1)
GO TO 8
103 CALL RDSAV(IP,NMS,NX,NM,NF,-1)
107 FORMAT(1X,A5)
TYPE 109
109 FORMAT(' TYPE ID NAME (<CR>=BACKUP) -- ',$)
ACCEPT 10,ID
IF(ID.EQ.' ')GO TO 102
JD=0
L=0
CC NX=NX-1
DO 110 K=1,10
IF(NMS(K).EQ.ID)JD=K
IF(NMS(K).EQ.' ')GO TO 112
L=K
110 IF(JD.EQ.0.AND.K.EQ.10)GO TO 1103
112 IF(N.EQ.'Z')GO TO 127
C FOR DELETIONS
L=L+1
IF(JD.NE.0)GO TO 111
C ADDS ON TO END
N=0
IP(L)=NX+1
DO 113 K=NX+1,MCLEF(1)+NX
N=N+1
113 NF(K)=MCLEF(N)
NX=NX+N
NMS(L)=ID
L=L+1
114 DO 115 K=1,NX
115 MCLEF(K)=NF(K)
C MOVES IT ALL TO MCLEF
GO TO 14
127 MCLEF(1)=0
111 N=IP(JD)
NR=MCLEF(1)
M=NF(IP(JD))
NW=NR-M
NX=NX+NW
IF(NW)201,120,203
201 JA=N+NR
JB=NX
JC=1
GO TO 204
203 JA=NX
JB=N+NW
JC=-1
204 DO 121 K=JA,JB,JC
121 NF(K)=NF(K-NW)
IF(NR.EQ.0)GO TO 126
120 DO 117 K=1,NR
NF(N)=MCLEF(K)
117 N=N+1
CC L=L-1
IF(NW.EQ.0)GO TO 114
DO 119 K=JD+1,L
119 IP(K)=IP(K)+NW
C FIXES UP FIRST LINE.
CC123 L=L-1
CC NX=NX-1
GO TO 114
126 IP(L+1)=0
CC L=L-1
DO 124 K=JD,L-1
IP(K)=IP(K+1)+NW
124 NMS(K)=NMS(K+1)
NMS(L)=' '
GO TO 114
END
SUBROUTINE RDSAV(KT,NMS,K,NAME,IO,L)
C POINTER LIST, NAME LIST, WDCNT, FILE NAME, DATA, RD OR WRT.
COMMON /RC/MCLEF(400),IST(4000)/FL/IC,NH,NQ,A,B,C,D
DIMENSION KT(1),NMS(1),IO(1),JALL(21)
IF(L)GO TO 5
C L=-1 FOR READER, -2=NO TYPE OF NAME LIST.
DO 1 N=1,10
JALL(N)=KT(N)
1 JALL(N+11)=NMS(N)
JALL(11)=K
CALL PUTFIL(NAME)
CALL FASTOU(JALL,21)
CALL FASTOU(IO,K+1)
CALL FINFIL
RETURN
5 CALL GETFIL(NAME)
CALL FASTIN(JALL,21)
K=JALL(11)
CALL FASTIN(IO,K)
DO 2 N=1,10
KT(N)=JALL(N)
2 NMS(N)=JALL(N+11)
IF(L.EQ.-2)RETURN
TYPE 3
TYPE 4,(NMS(N),N=1,10)
3 FORMAT(
1' 0 1 2 3 4 5 6 7
1 8 9')
4 FORMAT(' IDENT. NAMES:'/,10(2XA5))
END
SUBROUTINE CNVT
COMMON/RC/A(4400)
DIMENSION J(10),NM(10),M(600),JALL(21)
EQUIVALENCE(J,JALL,A),(NX,JALL(11)),(NM,JALL(12)),(M,A(2000))
C POINTER LIST, TOTAL WD CNT, NAME LIST.
TYPE 1
1 FORMAT(' TYPE OLD NAME -- '$)
ACCEPT 2,N
2 FORMAT(A5)
TYPE 3
3 FORMAT(' NEW NAME -- '$)
ACCEPT 2,NN
CALL IFILE(1,N)
NX=1
READ(1,4)K,J
4 FORMAT(12I)
6 READ(1,4,END=5)K,K,(M(L),L=NX,NX+K-1)
REREAD 7,L,NM
IF(NM(1))GO TO 5
NX=NX+K
GO TO 6
7 FORMAT(I,10A5)
5 NX=NX-1
CALL RDSAV(J,NM,NX,NN,M,0)
C POHπTERS, NAMES, WDCNT, FILE NAME, ARRAY, 0=WRITE
CALL EXIT
END